home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / risc_src.lha / risc_sources / sys / risc_dispatch.t < prev    next >
Text File  |  1989-06-30  |  11KB  |  310 lines
  1. (herald risc_dispatch (env tsys))
  2.  
  3. (define (dispatch-init)
  4.   (lap (handle-stype handle-true handle-fixnum handle-pair
  5.         handle-char handle-nonvalue *handlers* icall-wrong-nargs
  6.         bogus-return bogus-return-miss apply handle-immediate
  7.     handle-magic-frame no-default-method)
  8.  
  9.     (move link-reg a1)            ;movea kills this
  10.     (store l p (d@nil slink/dispatch))
  11.     (movea dispatch extra)
  12.     (store l extra (d@nil slink/dispatch-label))
  13.     (jr a1)
  14.     (move ($ -1) nargs)))
  15.  
  16.  
  17. (define *magic-frame-template*
  18.  (lap-template (4 -1 t stack magic-frame-handler)
  19.   (load l (d@r sp 16) link-reg)
  20.   (jr link-reg)
  21.   (add ($ 20) sp)
  22. magic-frame-handler
  23.   (load l (d@nil slink/dispatch) AN)
  24.   (load l (d@r AN (static handle-magic-frame)) A1)
  25.   (load l (d@r a1 2) a1)
  26.   (jbr dispatch)))
  27.  
  28. (define *structure-template*
  29.   (lap-template (0 1 nil heap structure-handler)
  30.     (load l (d@nil slink/undefined-effect) extra)
  31.     (jr extra)
  32.     (noop)
  33. structure-handler
  34.     (load l (d@r A1 -2) A1)                       ; internal-template
  35.     (load l (d@r A1 -30) A1)                        ; stype-handler
  36.     (jbr dispatch)))
  37.  
  38.     
  39. (define *stype-template*
  40.   (lap-template (9 1 nil heap stype-handler)           ; stype size is 9
  41.     (load l (d@nil slink/undefined-effect) extra)
  42.     (jr extra)
  43.     (noop)
  44. stype-handler
  45.     (load l (d@nil slink/dispatch) AN)
  46.     (load l (d@r AN (static handle-stype)) A1)
  47.     (load l (d@r a1 2) a1)
  48.     (jbr dispatch)))
  49.   
  50. (define *traced-op-template*
  51.   (lap-template (0 1 nil heap t-op)
  52.     (sub ($ 20) sp)
  53.     (store l link-reg (d@r sp 16))
  54.     (store l A1 (d@r sp 12))                                   ; self
  55.     (store l nil-reg (d@r sp 8))
  56.     (store l P (d@r sp 4))                                    ; op
  57.     (store l A1 (d@r sp 0))                                   ; obj
  58.     (jl dispatch)
  59.     (add ($ template-return-offset) link-reg)
  60.     (template 4 -1 t)
  61.     (load l (d@r sp 16) link-reg)
  62.     (j= AN nil-reg traced-op-default)    ; did we get a method?
  63.                     ; AN contains code
  64.     (move A1 P)                              ; environment
  65.     (load l (d@r SP 12) A1)                         ; self is first arg of method
  66.     (load l (d@r sp 0) AN+1)        ;obj
  67.     (jbr op-icall)
  68. traced-op-default
  69.     (load l (d@r P 6) P)                       ; rhs is operation
  70.     (jbr default)))
  71.  
  72.   
  73.  
  74. ;;; We have the operation in P, the object in A1 and we can use AN which is
  75. ;;; where the method id returned
  76.  
  77. (define *operation-template*
  78.   (lap-template (3 1 t heap operation-handler)
  79.     (sub ($ 20) sp)
  80.     (store l link-reg (d@r sp 16))
  81.     (store l A1 (d@r sp 12))                                   ; self
  82.     (store l nil-reg (d@r sp 8))
  83.     (store l P (d@r sp 4))                                    ; op
  84.     (store l A1 (d@r sp 0))                                   ; obj
  85.     (jl dispatch)
  86.     (add ($ template-return-offset) link-reg)
  87.     (template 4 -1 t)
  88.     (load l (d@r sp 16) link-reg)    ;dispatch return
  89.     (j= AN nil-reg default)                             ; did we get a method?
  90.     (move A1 P)
  91.     (load l (d@r SP 12) A1)                    ; self is first arg of method
  92.     (load l (d@r sp 0) AN+1)        ;obj
  93. op-icall
  94.     (load sb (d@r AN (- template/nargs 2)) vector) ;handler added this 2
  95.     (j= NARGS vector %icall-ok)         ; check number of args
  96.     (j< nargs vector %icall-wrong-nargs)
  97.     (load ub (d@r an (- template/header 2)) vector)
  98.     (jn= vector ($ (fx+ header/template 128)) %icall-wrong-nargs) 
  99. %icall-ok
  100.     (jr an)                ;handler gives code address (tp - 2)
  101.     (add ($ 20) sp)
  102. %icall-wrong-nargs
  103.   (load l (d@r SP 4) p)
  104.   (store l p (d@nil slink/p))   ; operation
  105.   (load l (d@nil slink/dispatch) P)
  106.   (load l (d@r P (static icall-wrong-nargs)) P)
  107.   (load l (d@r p 2) p)
  108.   (load l (d@r P -2) extra)
  109.   (add ($ 2) extra)
  110.   (jr extra)
  111.   (add ($ 20) SP)
  112. default
  113.   (load l (d@r SP 12) A1)                         ; self is first arg of method
  114.   (load l (d@r P offset/operation-default) P)
  115.   (j= p nil-reg no-default)
  116.   (load l (d@nil slink/icall) extra)
  117.   (jr extra)
  118.   (add ($ 20) SP)
  119. no-default    
  120.   (load l (d@r SP 4) p)   ; operation
  121.   (store l p (d@nil slink/p))
  122.   (load l (d@nil slink/dispatch) P)
  123.   (load l (d@r P (static no-default-method)) P)
  124.   (load l (d@r p 2) p)
  125.   (load l (d@r P -2) extra)
  126.   (add ($ 2) extra)
  127.   (jr extra)
  128.   (add ($ 20) SP)
  129. dispatch
  130.     (mask ($ 3) A1 vector)                 ; get object tag 
  131.     (jn= vector ($ tag/extend) object-not-extend) ; is it an extend?
  132.     (load l (d@r A1 -2) extra)                        ; get object's header
  133.     (mask ($ 3) extra vector)                 ; is it a template?
  134.     (jn= vector ($ tag/extend) object-not-closure)
  135.     (load ub (d@r extra template/nargs) vector)
  136.     (j= zero vector cit)         ; closure internal template?
  137.     (load sw (d@r extra template/handler) vector)                       ; get handler offset
  138.     (j= zero vector no-handler)                       ; it it's 0, no handler
  139.     (add extra vector)
  140.     (jr vector)                     ; call the handler
  141.     (noop)
  142. no-handler              
  143.     (jr link-reg)
  144.     (move nil-reg AN)
  145. cit
  146.     (load l (d@r extra 2) AN)                         ; get auxilliary template
  147.     (load sw (d@r AN template/handler) vector)                       ; get handler offset
  148.     (j= zero vector no-handler)
  149.     (add an vector)
  150.     (jr vector)
  151.     (noop)
  152. object-not-extend
  153.     (load l (d@nil slink/dispatch) AN)         ; establish addressability
  154.     (j= vector ($ tag/fixnum) fixnum)
  155.     (j= vector ($ tag/pair) pair)
  156.     (j= a1 t-reg true)
  157.     (mask ($ #xff) a1 vector)
  158.     (j= vector ($ header/char) char)
  159.     (j= vector ($ header/nonvalue) nonvalue)
  160.     (load l (d@r AN (static handle-immediate)) A1)
  161.     (load l(d@r a1 2) a1)
  162.     (jbr dispatch)
  163. true
  164.     (load l (d@r AN (static handle-true)) A1)
  165.     (load l (d@r a1 2) a1)
  166.     (jbr dispatch)
  167. nonvalue
  168.     (load l (d@r AN (static handle-nonvalue)) A1)
  169.     (load l (d@r a1 2) a1)
  170.     (jbr dispatch)
  171. fixnum   
  172.     (load l (d@r AN (static handle-fixnum)) A1)
  173.     (load l (d@r a1 2) a1)
  174.     (jbr dispatch)
  175. pair
  176.     (load l (d@r AN (static handle-pair)) A1)
  177.     (load l (d@r a1 2) a1)
  178.     (jbr dispatch)
  179. char
  180.     (load l (d@r AN (static handle-char)) A1)
  181.     (load l (d@r a1 2) a1)
  182.     (jbr dispatch)
  183. object-not-closure
  184.     (j= vector zero frame-op)
  185.     (load l (d@nil slink/dispatch) AN)
  186.     (load l (d@r AN (static *handlers*)) AN)
  187.     (load l (d@r an 2) an)
  188.     (mask ($ #x7c) extra vector)                 ; isolate low seven bits
  189.     (add an vector)
  190.     (load l (d@r vector 2) a1)              ; index into vector of handlers
  191.     (jbr dispatch)
  192. frame-op
  193.     (sub ($ 2) extra)            ;coerce to template
  194.     (load sw (d@r extra template/handler) vector)                       ; get handler offset
  195.     (j= zero vector no-handler)                       ; it it's 0, no handler
  196.     (add extra vector)
  197.     (jr vector)                     ; call the handler
  198.     (noop)
  199. operation-handler
  200.     (load l (d@r A1 offset/operation-handler) A1)
  201.     (jbr dispatch)))
  202.  
  203. ;;; At the top of the join loop the stack looks like    self                       
  204. ;;;                                                     next
  205. ;;;                                                     op
  206. ;;;                                                     obj
  207. ;;;                                               sp -> dispatch-return
  208.  
  209. (define *join-template*
  210.   (lap-template (2 1 t heap join-handler)
  211. join-template
  212.     (load l (d@r P 2) P)                     ; joined lhs
  213.     (load l (d@nil slink/icall) extra)
  214.     (jr extra)
  215.     (noop)
  216. join-handler                                            
  217.     (sub ($ 4) sp)
  218.     (store l link-reg (d@r sp 0))
  219.     (load l (d@r A1 6) extra)
  220.     (store l extra (d@r SP 12))          ; next <- rhs
  221.     (load l (d@r A1 2) A1)                   ; get joined lhs
  222.     (store l A1 (d@r SP 4))                   ; obj  <- lhs
  223.     (jl dispatch)
  224.     (add ($ template-return-offset) link-reg)               ; try to get a handler from lhs
  225.     (template 0 -1 t)
  226. join-return
  227.     (load l (d@r sp 0) link-reg)
  228.     (j= AN nil-reg join-miss)                      ; did we get a handler?
  229.     (jr link-reg)
  230.     (add ($ 4) sp)
  231. join-miss
  232.     (load l (d@r SP 12) A1)                  ; get next
  233.     (store l A1 (d@r SP 4))                   ; obj <- next
  234.     (store l nil-reg (d@r SP 12)) ; next <- tbsh
  235.     (add ($ 4) sp)
  236.     (jbr dispatch)))                 ; try rhs
  237.  
  238.  
  239. (define *bogus-entity-template*
  240.   (lap-template (2 1 t heap bogus-entity-handler)
  241.     (load l (d@r P 2) P)
  242.     (load l (d@nil slink/icall) extra)
  243.     (jr extra)
  244.     (noop)
  245. bogus-entity-handler
  246.     (sub ($ 8) sp)
  247.     (store l link-reg (d@r sp 4))
  248.     (store l p (d@r sp 0))        ;save p
  249.     (move A1 AN)            ;temp
  250.     (move P A1)                        ; operation is argument to handler
  251.     (load l (d@r AN 6) p)               ; bogus-entity handler
  252.     (load l (d@nil slink/icall) extra)
  253.     (jalr extra)
  254.     (add ($ template-return-offset) link-reg)
  255.     (template 1 -3 nil)            ;return method and args
  256.     (jn= A1 nil-reg bogus-return-hit)
  257.     (load l (d@nil slink/dispatch) AN)
  258.     (move a2 a3)            ;args
  259.     (load l (d@r AN (static bogus-return-miss)) A1) ;A2 has dummy value
  260.     (load l (d@r a1 2) a1)
  261.     (load l (d@r AN (static apply)) P)
  262.     (load l (d@r p 2) p)
  263.     (load l (d@r P -2) extra)
  264.     (add ($ 2) extra)
  265.     (jr extra)
  266.     (move ($ 4) nargs)
  267. bogus-return-hit
  268.     (load l (d@nil slink/dispatch) AN)
  269.     (move a2 a4)               ; args
  270.     (move A1 A2)                       ; method
  271.     (load l (d@r AN (static bogus-return)) A1)
  272.     (load l (d@r a1 2) a1)
  273.     (load l (d@r AN (static apply)) P)
  274.     (load l (d@r p 2) p)
  275.     (load l (d@r P -2) extra)
  276.     (add ($ 2) extra)
  277.     (jr extra)
  278.     (move ($ 5) NARGS)      ; dummy obj in a3
  279. bogus-return-handler
  280.     (jr link-reg)
  281.     (move nil-reg AN)))
  282.  
  283. (define (bogus-return-miss method  . args)
  284.   (lap ()
  285.     (move nil-reg AN)                  ; compiled handlers return register
  286.     (load l (d@r sp 0) p)
  287.     (load l (d@r sp 4) link-reg)
  288.     (jr link-reg)
  289.     (add ($ 8) SP)))                    
  290.  
  291.  
  292. (define (bogus-return method obj . args)
  293.   (lap ()
  294.     (move A1 P)                        ; method in procedure register
  295.     (movea join-return A1)          ; is a join return address on top?
  296.     (load l (d@r sp 4) link-reg)
  297.     (add ($ 8) sp)
  298.     (jn= a1 link-reg bogus-dispatch-return)
  299.     (add ($ 4) SP)                      ; pop join return addr
  300. bogus-dispatch-return
  301.     (load l (d@r sp 16) link-reg)
  302.     (load l (d@r SP 12) A1)              ; self is first of interpreted method
  303.     (load l (d@r SP 0)  A2)              ; obj is second of interpreted method
  304.     (load l (d@nil slink/icall) extra)
  305.     (jr extra)
  306.     (add ($ 20) SP)))
  307.  
  308.  
  309.  
  310. (dispatch-init)